' Author: Alberto Alday 17-01-2007
'
' This class creates a maps a named shared memory block
' It also gives functions for reading and writing on this memory

Imports System.Runtime.InteropServices
Public Class MemMap

    Private Declare Function CreateFileMapping Lib "kernel32" Alias "CreateFileMappingA" (ByVal hFile As Integer, ByVal lpFileMappigAttributes As IntPtr, ByVal flProtect As Integer, ByVal dwMaximumSizeHigh As Integer, ByVal dwMaximumSizeLow As Integer, ByVal lpName As String) As Integer
    Private Declare Function MapViewOfFile Lib "kernel32" Alias "MapViewOfFile" (ByVal hFileMappingObject As Integer, ByVal dwDesiredAccess As Integer, ByVal dwFileOffsetHigh As Integer, ByVal dwFileOffsetLow As Integer, ByVal dwNumberOfBytesToMap As Integer) As Integer
    Private Declare Function unMapViewOfFile Lib "kernel32" Alias "UnmapViewOfFile" (ByVal Address As Integer) As Integer
    Private Declare Function OpenFileMapping Lib "kernel32" Alias "OpenFileMappingA" (ByVal dwDesiredAccess As Integer, ByVal bInheritHandle As Integer, ByVal lpName As String) As Integer
    Private Declare Function GetLastError Lib "kernel32" Alias "GetLastError" () As Integer
    Private Declare Function CloseHandle Lib "kernel32" Alias "CloseHandle" (ByVal hObject As Integer) As Integer
    Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (ByVal lpMutexAttributes As IntPtr, ByVal bInitialOwner As Integer, ByVal lpName As String) As Integer
    Private Declare Function ReleaseMutex Lib "kernel32" Alias "ReleaseMutex" (ByVal hMutex As Integer) As Integer
    Private Declare Function WaitForSingleObject Lib "kernel32" Alias "WaitForSingleObject" (ByVal hHandle As Integer, ByVal dwMilliseconds As Integer) As Integer
    Private Declare Function InterlockedExchange Lib "kernel32" Alias "InterlockedExchange" (ByVal Target As Integer, ByVal Value As Integer) As Integer
    Private Declare Function InterlockedCompareExchange Lib "kernel32" Alias "InterlockedCompareExchange" (ByVal Target As Integer, ByVal Value As Integer, ByVal Comperand As Integer) As Integer
    Private Declare Sub Sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)

    Private Const ERROR_ALREADY_EXISTS As Integer = 183

    Private Const PAGE_NOACCESS As Integer = &H1
    Private Const PAGE_READONLY As Integer = &H2
    Private Const PAGE_READWRITE As Integer = &H4
    Private Const PAGE_WRITECOPY As Integer = &H8
    Private Const PAGE_EXECUTE As Integer = &H10
    Private Const PAGE_EXECUTE_READ As Integer = &H20
    Private Const PAGE_EXECUTE_READWRITE As Integer = &H40
    Private Const PAGE_EXECUTE_WRITECOPY As Integer = &H80
    Private Const PAGE_GUARD As Integer = &H100
    Private Const PAGE_NOCACHE As Integer = &H200
    Private Const PAGE_WRITECOMBINE As Integer = &H400
    Private Const MEM_COMMIT As Integer = &H1000
    Private Const MEM_RESERVE As Integer = &H2000
    Private Const MEM_DECOMMIT As Integer = &H4000
    Private Const MEM_RELEASE As Integer = &H8000
    Private Const MEM_FREE As Integer = &H10000
    Private Const MEM_PRIVATE As Integer = &H20000
    Private Const MEM_MAPPED As Integer = &H40000
    Private Const MEM_RESET As Integer = &H80000
    Private Const MEM_TOP_DOWN As Integer = &H100000
    Private Const MEM_WRITE_WATCH As Integer = &H200000
    Private Const MEM_PHYSICAL As Integer = &H400000
    Private Const MEM_LARGE_PAGES As Integer = &H20000000
    Private Const MEM_4MB_PAGES As Integer = &H80000000
    Private Const SEC_FILE As Integer = &H800000
    Private Const SEC_IMAGE As Integer = &H1000000
    Private Const SEC_RESERVE As Integer = &H4000000
    Private Const SEC_COMMIT As Integer = &H8000000
    Private Const SEC_NOCACHE As Integer = &H10000000
    Private Const MEM_IMAGE As Integer = SEC_IMAGE

    Private Const FILE_MAP_WRITE As Integer = SECTION_MAP_WRITE
    Private Const SECTION_MAP_WRITE As Integer = &H2
    Private Const SECTION_MAP_READ As Integer = &H4

    Const INFINITE As Integer = &HFFFF      '  Infinite timeout

    Public ReadOnly mapName As String
    Private mapHandle As Integer
    Public ReadOnly mapAddress As Integer
    Private mapPointer As IntPtr
    Private PID As Integer
    Public ReadOnly mapSize As Integer

    Public ReadOnly IsNew As Boolean = True

    Public Enum LockTypeEnum
        SPIN_LOCK = 1
        SLEEP_LOCK = 2
    End Enum

    Public LockType As LockTypeEnum = LockTypeEnum.SLEEP_LOCK
    Private closed As Boolean = False


    Public Sub New(ByVal Name As String, ByVal Size As Integer)
        PID = Process.GetCurrentProcess.Id
        mapHandle = CreateFileMapping(0, IntPtr.Zero, PAGE_READWRITE, 0, Size, "Global/" + Name)
        If mapHandle = 0 Then
            Throw New Exception("FileMapping:" + Name + " error:" + GetLastError.ToString)
        Else
            If GetLastError = ERROR_ALREADY_EXISTS Then
                ' What is the real size????
                IsNew = False
            End If
        End If
        mapSize = Size
        mapName = Name
        mapAddress = MapViewOfFile(mapHandle, FILE_MAP_WRITE, 0, 0, 0)
        If mapAddress = 0 Then
            CloseHandle(mapHandle)
            Throw New Exception("MapViewOfFile error:" + GetLastError.ToString)
        End If
        mapPointer = New IntPtr(mapAddress)
    End Sub

    Protected Overrides Sub finalize()
        Me.close()
    End Sub

    Public Sub close()
        If closed Then Exit Sub
        unMapViewOfFile(mapAddress)
        CloseHandle(mapHandle)
        mapPointer = Nothing
        closed = True
    End Sub

    ' A 4 bytes zone is necesary 32bit aligned
    Public Sub interLock(ByVal offset As Integer)
        Dim lValue As Integer
        Dim i As Integer
        While True
            lValue = InterlockedCompareExchange(mapAddress + offset, PID, 0)
            If lValue = 0 Then
                Return
            End If

            If LockType = LockTypeEnum.SLEEP_LOCK Then
                Sleep(0)
            End If
            i += 1
            If i > 1000 Then
                i = 0
                Try
                    lValue = Process.GetProcessById(lValue).Id
                Catch ex As Exception
                    interUnlock(offset)  ' May be unsafe but protects agains killing processes holding a lock
                End Try
            End If

        End While
    End Sub

    Public Sub interUnlock(ByVal offset As Integer)
        Me.writeInt32(offset, 0)
    End Sub

    Public Property memAddress() As Integer
        Get
            Return mapAddress
        End Get
        Set(ByVal Value As Integer)

        End Set
    End Property

    Public Function readInt32(ByVal offset As Integer) As Integer
        Return Marshal.ReadInt32(mapPointer, offset)
    End Function

    Public Sub writeInt32(ByVal offset As Integer, ByVal value As Integer)
        Marshal.WriteInt32(mapPointer, offset, value)
    End Sub
    Public Function readInt64(ByVal offset As Integer) As Long
        Return Marshal.ReadInt64(mapPointer, offset)
    End Function

    Public Sub writeInt64(ByVal offset As Integer, ByVal value As Long)
        Marshal.WriteInt64(mapPointer, offset, value)
    End Sub
    Public Function readInt16(ByVal offset As Integer) As Int16
        Return Marshal.ReadInt16(mapPointer, offset)
    End Function

    Public Sub writeInt16(ByVal offset As Integer, ByVal value As Int16)
        Marshal.WriteInt16(mapPointer, offset, value)
    End Sub

    Public Function readByte(ByVal offset As Integer) As Byte
        Return Marshal.ReadByte(mapPointer, offset)
    End Function

    Public Sub writeByte(ByVal offset As Integer, ByVal value As Byte)
        Marshal.WriteByte(mapPointer, offset, value)
    End Sub


    Public Sub writeStringAuto(ByVal offset As Integer, ByVal value As String)
        Me.writeInt32(offset, value.Length)
        Marshal.Copy(value.ToCharArray, 0, (New IntPtr(mapAddress + offset + 4)), value.Length)
    End Sub

    Public Sub writeString(ByVal offset As Integer, ByVal value As String)
        Debug.WriteLine("writeString:" + offset.ToString + "(" + value.Length.ToString + ")-" + value)
        Marshal.Copy(value.ToCharArray, 0, (New IntPtr(mapAddress + offset)), value.Length)
    End Sub

    Public Function readString(ByVal offset As Integer, ByVal size As Integer) As String
        Return Marshal.PtrToStringAuto(New IntPtr(mapAddress + offset), size)
    End Function
    Public Function readStringAuto(ByVal offset As Integer) As String
        Dim lsize As Integer
        lsize = Me.readInt32(offset)
        Return Marshal.PtrToStringAuto(New IntPtr(mapAddress + offset + 4), lsize)
    End Function

    Public Sub writeIntArray(ByVal offset As Integer, ByVal intArray As Integer())
        Marshal.Copy(intArray, 0, New IntPtr(mapAddress + offset), intArray.Length)
    End Sub

    Public Function readIntArray(ByVal offset As Integer, ByVal size As Integer) As Integer()
        Dim ret(size) As Integer
        Marshal.Copy(New IntPtr(mapAddress + offset), ret, 0, size)
        Return ret
    End Function
End Class
